home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
glass
/
glass.lha
/
GLASS
/
contsens
/
errorenv.c
< prev
next >
Wrap
C/C++ Source or Header
|
1991-02-08
|
22KB
|
941 lines
/* Copyright (C) 1990 Riet Oolman
This file is part of GLASS.
GLASS is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 1, or (at your option)
any later version.
GLASS is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GLASS; see the file COPYING. If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
/* file: errorenv.c
author: H. Oolman
last modified: 8-2-1991
purpose: error registration,
error printing,
updating of type environment
general functions on lists */
#include "handleds.h"
#include "check.ds.h"
#include "check.var.h"
#include "check.afuncs.h"
#include "errorenv.h"
Void error(ernm, tyfst, tysnd, name, erval, iswarn)
long ernm;
typcrec *tyfst, *tysnd;
symbol name;
val erval;
boolean iswarn;
{
/* error messages (warning if iswarn), in which a name may occur are stored.
erval: expression with the error in its type
They may become
invalid yet, so are not yet printed. It is assumed that 'UNKNOWN' types
for parts of expressions are not filled in !! (since these would have to be
changed back too) */
errorrec *e;
/* error */
if (iswarn && !takewarning)
return;
e = (errorrec *)malloc(sizeof(errorrec));
e->erno = ernm;
if (name != NULL) e->sym = Copysymbol(name);
else e->sym = NULL;
/* a copy, because unique extensions not wanted here */
e->tyf = tyfst;
e->tys = tysnd;
e->errval = erval;
e->nesting = nestednames;
e->orig = nestednorig;
e->next = errorlist;
errorlist = e;
}
/* for printing errormessages: */
#define max 99
typedef long intl[max + 1];
Void myprint_orig(f, org)
FILE *f;
orig org;
{ putc( '(', f );
fprint_string( f, org->file );
putc( ',', f );
fprint_inum( f, org->line );
putc( ')', f ); /* no newline at end, like myprint_orig has */
}
boolean EmporSomUnk(ty)
typcrec *ty;
/* true <-> ty is EMPTYT or SOME (UNKNOWN t)
when you forget the INDIRs
Used because in case of !takewarning, EMPTYT and SOME (UNKNOWN t)
are treated the same
Beautifies printing CT t_0 (CT t_1 (SOME (UNKNOWN t))):
gives t_0 & t_1, instead of t_0 $ t_1 $ t*
Small disadvantage: t* -> t* (with t a type variable) is printed as <> -> <>
*/
{ typcrec *ty1;
while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
if (ty->kind == kindEMPTYT) return true;
else
{ if (ty->kind == kindSOME)
{ ty1 = ty->SOME.tcpart;
while (ty1->kind == kindINDIR) ty1 = ty1->INDIR.tcind;
return (ty1->kind == kindUNKNOWN);
}
else return false;
};
}
Local Void Writetypcptr1 PP((FILE *f, typcrec *ty));
/* Local variables for Writeloctypes: */
struct LOC_Writeloctypes {
intl unknrs;
nminstrec *locs;
long lastu;
} ;
Local Void wlt(f,ty, LINK)
FILE *f;
typcrec *ty;
struct LOC_Writeloctypes *LINK;
{ long i;
nminstrec *l;
boolean found;
long FORLIM;
while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
switch (ty->kind) {
case kindUNKNOWN:
i = 0;
found = false;
FORLIM = LINK->lastu;
for (i = 0; i <= FORLIM; i++)
found = (found || LINK->unknrs[i] == ty->UNKNOWN.unknm);
if (!found) {
if (LINK->lastu == 0 && LINK->locs == NULL)
putc('{',f);
else
fprintf(f,", ");
fprintf(f,"Unkn");
fprintf(f,"%ld", ty->UNKNOWN.unknm);
if (LINK->lastu < max) {
LINK->lastu++;
LINK->unknrs[LINK->lastu] = ty->UNKNOWN.unknm;
}
}
break;
case kindLOC:
l = LINK->locs;
found = false;
while (l != NULL) {
found |= (Equalsymbol(l->nm, ty->LOC.locname) &&
l->inst == ty->LOC.inst);
l = l->next;
}
if (!found) {
if (LINK->lastu == 0 && LINK->locs == NULL)
putc('{',f);
else
fprintf(f,", ");
Writesymbol(f, ty->LOC.locname);
if (takewarning) fprintf(f, "/* inst. %ld */",ty->LOC.inst);
l = (nminstrec *)malloc(sizeof(nminstrec));
l->nm = ty->LOC.locname;
l->inst = ty->LOC.inst;
l->next = LINK->locs;
LINK->locs = l;
}
break;
case kindSINGLEARROW:
wlt(f,ty->SINGLEARROW.tcarg, LINK);
wlt(f,ty->SINGLEARROW.tcres, LINK);
break;
case kindINT:
case kindFLOAT:
case kindBOOL:
case kindSTRING:
case kindEMPTYT:
case kindBASETY:
case kindAPS: /* nothing */
break;
case kindSYSTY:
wlt(f,ty->SYSTY.syscomp, LINK);
break;
case kindCT:
wlt(f,ty->CT.tcfirst, LINK);
wlt(f,ty->CT.tcrest, LINK);
break;
case kindSOME:
if (takewarning || !(EmporSomUnk(ty)))
{wlt(f,ty->SOME.tcpart, LINK);}
break;
case kindALL:
break;
}
} /* wlt */
Local Void Writeloctypes(f,ty)
FILE *f;
typcrec *ty;
{
/* write the set of all UNKNOWNs */
struct LOC_Writeloctypes V;
V.lastu = 0;
V.locs = NULL;
wlt(f,ty, &V);
if (V.lastu > 0 || V.locs != NULL) fprintf(f,"} ");
} /* Writeloctypes */
#undef max
Local Void Writesystemtype PP((FILE *f, dirgraphrec *dg, typcrec *ty));
Local Void Writedirgraphptr(f, dg)
FILE *f;
dirgraphrec *dg;
{
/* prints the sidections in a system type */
switch (dg->kind) {
case kindCd:
putc('(', f);
Writedirgraphptr(f, dg->Cd.dgfirst);
fprintf(f, ") (");
Writedirgraphptr(f, dg->Cd.dgrest);
putc(')', f);
break;
case kindSd:
putc('(', f);
Writedirgraphptr(f, dg->Sd.dgpart);
fprintf(f, ")* (");
Writedirgraphptr(f, dg->Sd.dglast);
putc(')', f);
break;
case kindOd:
switch (dg->Od.basedir->kind) {
case kindINTO:
putc('?', f);
break;
case kindOUT:
putc('!', f);
break;
case kindNON:
fprintf(f, "none");
break;
}
break;
}
} /* Writedirgraphptr */
Local Void WritesystyCT(f, dg, ty, first)
FILE *f;
dirgraphrec *dg;
typcrec *ty;
boolean first;
{
/* tries to write out a type with directions and CT or SOME in it, so one that should
end in empty
When first is true, ty->kind is SOME or CT */
dirgraphrec *sd, *fd;
while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
switch (ty->kind) {
case kindCT:
if (!first)
fprintf(f, " & ");
putc('(', f);
if (dg->kind == kindCd) {
fd = dg->Cd.dgfirst;
sd = dg->Cd.dgrest;
} else {
if (dg->kind == kindSd) {
fd = dg->Sd.dgpart;
sd = dg;
} else {
if (dg->kind == kindOd) {
fd = dg;
sd = dg;
}
}
}
Writesystemtype(f, fd, ty->CT.tcfirst);
putc( ')',f);
if (first && !takewarning && EmporSomUnk(ty->CT.tcrest))
fprintf(f,"^1"); /* 't CT <>' can not be printed with &'s */
else
WritesystyCT(f, sd, ty->CT.tcrest, false);
break;
case kindEMPTYT:
break;
case kindSOME:
if (dg->kind == kindCd)
WritesystyCT(f,dg,BuildCT(ty->SOME.tcpart,ty),first);
else { /* dir. at end neglected */
if (dg->kind == kindOd) fd = dg;
else fd = dg->Sd.dgpart;
if (first) {
if (!takewarning && EmporSomUnk(ty))
fprintf(f,"<>");
else {
putc('(', f);
Writesystemtype(f, fd, ty->SOME.tcpart);
fprintf(f, ")*");
}
} else {
if (takewarning || !(EmporSomUnk(ty)))
{ fprintf(f,"& (");
Writesystemtype(f, fd, ty->SOME.tcpart);
fprintf(f,") ... & (");
Writesystemtype(f, fd, ty->SOME.tcpart);
putc(')',f);
}
}
}
break;
case kindUNKNOWN:
if (takewarning) fprintf(f, "..something unknown..");
break;
case kindSINGLEARROW:
case kindINT:
case kindFLOAT:
case kindBOOL:
case kindSTRING:
case kindSYSTY:
case kindLOC:
case kindBASETY:
case kindALL:
case kindAPS:
fprintf(f, "& ??");
break;
}
} /* WritesystyCT */
Local Void Writesystemtype(f, dg, ty)
FILE *f;
dirgraphrec *dg;
typcrec *ty;
{
/* tries to write the directions dg of a systemtype in between the
bundletype ty */
while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
switch (dg->kind) {
case kindCd:
if (ty->kind == kindCT || ty->kind == kindSOME)
WritesystyCT(f, dg, ty, true);
else { /* should not occur... */
fprintf(f, "with directions ");
Writedirgraphptr(f, dg);
fprintf(f, " in ");
Writetypcptr1(f, ty);
}
break;
case kindOd:
switch (dg->Od.basedir->kind) {
case kindINTO:
fprintf(f, "?(");
break;
case kindOUT:
fprintf(f, "!(");
break;
case kindNON: /* nothing, like in GLASS */
break;
}
Writetypcptr1(f, ty);
if (dg->Od.basedir->kind != kindNON)
putc(')', f);
break;
case kindSd:
if (ty->kind == kindCT || ty->kind == kindSOME)
WritesystyCT(f, dg, ty, true);
else { /* should not occur... */
fprintf(f, "with directions ");
Writedirgraphptr(f, dg);
fprintf(f, " in ");
Writetypcptr1(f, ty);
}
break;
}
} /* Writesystemtype */
Local Void Writetypcptr1(f, ty)
FILE *f;
typcrec *ty;
{
while (ty->kind == kindINDIR) ty = ty->INDIR.tcind;
switch (ty->kind) {
case kindSINGLEARROW:
putc('(', f);
Writetypcptr1(f, ty->SINGLEARROW.tcarg);
fprintf(f, ") -> ");
Writetypcptr1(f, ty->SINGLEARROW.tcres);
break;
case kindINT:
fprintf(f, "INT");
break;
case kindFLOAT:
fprintf(f, "FLOAT");
break;
case kindSTRING:
fprintf(f, "STRING");
break;
case kindBOOL:
fprintf(f, "BOOL");
break;
case kindSYSTY:
putc('[', f);
Writesystemtype(f, ty->SYSTY.sysdirs, ty->SYSTY.syscomp);
putc(']', f);
break;
case kindEMPTYT:
fprintf(f, "<>");
break;
case kindCT:
WritesystyCT(f,BuildOd(BuildNON()),ty,true);
/* print this as if interwoven with (empty) directions */
break;
case kindAPS:
fprintf(f, "APPSET");
break;
case kindUNKNOWN:
fprintf(f, "Unkn");
fprintf(f, "%ld", ty->UNKNOWN.unknm);
break;
case kindSOME:
WritesystyCT(f,BuildOd(BuildNON()),ty,true);
/* print this as if interwoven with (empty) directions */
break;
case kindLOC:
Writesymbol(f, ty->LOC.locname);
if (takewarning) fprintf(f, "/* inst. %ld */",ty->LOC.inst);
break;
case kindBASETY:
Writesymbol(f, ty->BASETY.btname);
if (takewarning && ty->BASETY.bor != NULL) {
fprintf(f, "/*");
myprint_orig(f, ty->BASETY.bor);
fprintf(f, "*/");
}
break;
case kindALL:
break;
}
} /* Writetypcptr1 */
Local Void Writetypcptr(f, ty)
FILE *f;
typcrec *ty;
{
/* tries to print a type as understandable as possible */
Writeloctypes(f,ty);
Writetypcptr1(f, ty);
} /* Writetypcptr */
Local boolean equalnested(nms1, nms2)
symbol nms1, nms2;
{
/* tests if nms1 and nms2 are the same list of names */
boolean Result;
Result = (nms1 == NULL && nms2 == NULL);
if (nms1 != NULL && nms2 != NULL)
return (Equalsymbol(nms1, nms2) & equalnested(nms1->next, nms2->next));
return Result;
} /* equalnested */
Local Void writenestednames(f,nms)
FILE *f;
symbol nms;
{ /* write out the names in the list nms in reverse order, separated by / */
if (nms == NULL) return;
writenestednames(f,nms->next);
if (nms->next != NULL) putc('/',f);
Writesymbol(f, nms);
} /* writenestednames */
Void printerrors(unparsval, errorlist)
_PROCEDURE unparsval;
errorrec *errorlist;
{
/* prints error messages concerning type errors
unparsval: unparses valptr's; differs for full and kernel check
errorlist: errors to be printed */
if (errorlist == NULL) return;
printerrors(unparsval, errorlist->next); /* stored in reverse */
errordiscovered = true;
if (errorlist->next != NULL) {
if (!equalnested(errorlist->nesting, errorlist->next->nesting)) {
if (errorlist->nesting != NULL){
fprintf(stderr,"in ");
writenestednames(stderr,errorlist->nesting);
if (errorlist->orig != NULL && takewarning) {
putc(' ',stderr);
myprint_orig(stderr, errorlist->orig);
}
fprintf(stderr,":\n"); }
}
} else {
if (errorlist->nesting != NULL) {
fprintf(stderr,"in ");
writenestednames(stderr,errorlist->nesting);
if (errorlist->orig != NULL && takewarning) {
putc(' ',stderr);
myprint_orig(stderr, errorlist->orig);
}
fprintf(stderr,":\n");}
}
fprintf(stderr," ");
switch (errorlist->erno) {
case 0:
fprintf(stderr,"typenaming \"");
Writesymbol(stderr, errorlist->sym);
fprintf(stderr,"\" cyclicly defined\n");
break;
case 1:
fprintf(stderr,"undefined name \"");
Writesymbol(stderr, errorlist->sym);
fprintf(stderr,"\" in type declaration\n");
break;
case 2:
fprintf(stderr,
"(W) description can be interpreted both directionally and adirectionally\n");
break;
/* !! (W) must coincide with true as last parameter of 'error' */
case 3:
fprintf(stderr,"(W) both uni- and adirectional interpretation give errors\n");
break;
case 4:
fprintf(stderr,"no parametertype for parameter\n");
break;
case 5:
fprintf(stderr,"wrong type `");
Writetypcptr(stderr, errorlist->tyf);
fprintf(stderr,"' for `");
(*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
stderr, errorlist->errval);
fprintf(stderr,"'\n");
break;
case 6:
putc('`',stderr);
(*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
stderr, errorlist->errval);
fprintf(stderr,"' can not be typed with `");
Writetypcptr(stderr, errorlist->tyf);
if (errorlist->tys!=NULL)
{ fprintf(stderr,"' and `");
Writetypcptr(stderr, errorlist->tys);}
fprintf(stderr,"' for subpart(s)\n");
break;
case 7:
fprintf(stderr,"!!contsens: length of name surpassed: truncated!!\n");
break;
case 8:
fprintf(stderr,"syntactically incorrect system type (after writing out)\n");
break;
case 9:
Writesymbol(stderr, errorlist->sym);
fprintf(stderr," defined more than once\n");
break;
case 10:
fprintf(stderr,"bug in program (");
Writesymbol(stderr, errorlist->sym);
fprintf(stderr,"); alarm author\n");
break;
case 11:
fprintf(stderr,"type `");
Writetypcptr(stderr, errorlist->tyf);
fprintf(stderr,"' occurs as part of itself\n");
break;
case 12:
fprintf(stderr,"incompatible types `");
Writetypcptr(stderr, errorlist->tyf);
fprintf(stderr,"' and `");
Writetypcptr(stderr, errorlist->tys);
fprintf(stderr,"' in `");
(*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
stderr, errorlist->errval);
fprintf(stderr,"'\n");
break;
case 13:
fprintf(stderr,"conflicting directions in type of ");
(*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
stderr, errorlist->errval);
putc('\n',stderr);
break;
case 14:
fprintf(stderr,"wrong directions in type of ");
(*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
stderr, errorlist->errval);
putc('\n',stderr);
break;
case 15:
fprintf(stderr,"tuple/list type wanted for `");
(*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
stderr, errorlist->errval);
fprintf(stderr,"'; `");
Writetypcptr(stderr, errorlist->tyf);
fprintf(stderr,"' found\n");
break;
case 16:
putc('`',stderr);
(*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
stderr, errorlist->errval);
fprintf(stderr,"' (type: `");
Writetypcptr(stderr, errorlist->tyf);
fprintf(stderr,"') should have been a connection\n");
break;
case 17:
fprintf(stderr,"list type expected in `");
(*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
stderr, errorlist->errval);
fprintf(stderr,"'\n");
break;
case 18:
fprintf(stderr,"type (after writing out) is not according to the syntax\n");
break;
case 19:
fprintf(stderr,"only names allowed as formal parameter of def.\n");
break;
case 20:
fprintf(stderr,"expression in power type too complicated\n");
break;
case 21:
fprintf(stderr,"(W) undefined name \"");
Writesymbol(stderr, errorlist->sym);
fprintf(stderr,"\" used in power type\n");
break;
case 22:
fprintf(stderr,"(W) have you maybe forgotten to declare \"");
Writesymbol(stderr, errorlist->sym);
fprintf(stderr,"\"?\n");
break;
case 23:
fprintf(stderr,"system type expected\n");
break;
case 24:
fprintf(stderr,"index in `");
(*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
stderr, errorlist->errval);
fprintf(stderr,"' too large\n");
break;
case 25:
fprintf(stderr,"index in `");
(*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
stderr, errorlist->errval);
fprintf(stderr,"' too small\n");
break;
case 26:
fprintf(stderr,"undefined atomname ");
Writesymbol(stderr, errorlist->sym);
putc('\n',stderr);
break;
case 27:
putc('`',stderr);
(*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
stderr, errorlist->errval);
fprintf(stderr,"' cannot be turned into kernel Glass\n");
break;
case 28:
fprintf(stderr,"(W) I put {...} around`");
(*(Void(*) PP((FILE *f, val vl)))unparsval.proc)(
stderr, errorlist->errval);
fprintf(stderr,"' because only adir. interpretation can be correct\n");
break;
default:
fprintf(stderr,"error number (%ld) too large\n", errorlist->erno);
break;
}
} /* printerrors */
Void addext(nm, ext)
symbol nm;
long ext;
{ /* replace name nm with extended name nm_ext */
long lb, lg, i, rest, lth;
lb = 1;
lg = 0;
while (lb * 10 <= ext) {
lb *= 10;
lg++;
}
rest = ext;
lth = nm->length;
for (i = 0; i <= lg + 1; i++) {
if (lth < wordlength) {
lth++;
if (i == 0)
nm->body[lth - 1] = '_';
else {
nm->body[lth - 1] = (Char)(rest / lb + '0');
rest %= lb;
lb /= 10;
}
} else
error(7L, NULL, NULL, NULL, NULL, false);
}
nm->length = lth;
}
/* for environment: */
Void mark_(curenv)
envrec **curenv;
{
/* mark point where piece of curenv added in front may be chopped off,
by element with empty name (assumption: no normal name has length 0) */
envrec *r;
r = (envrec *)malloc(sizeof(envrec));
/* added in front, to make removing added elements easy */
r->next = *curenv;
r->name0 = marker;
*curenv = r;
} /* mark */
Local boolean partunknown(t)
typcrec *t;
{
boolean Result;
while (t->kind == kindINDIR) t = t->INDIR.tcind;
switch (t->kind) {
case kindUNKNOWN:
Result = t->UNKNOWN.mustconn;
break;
case kindCT:
Result = partunknown(t->CT.tcfirst) | partunknown(t->CT.tcrest);
break;
case kindSOME:
Result = partunknown(t->SOME.tcpart);
break;
case kindSINGLEARROW:
case kindINT:
case kindFLOAT:
case kindBOOL:
case kindSTRING:
case kindSYSTY:
case kindEMPTYT:
case kindLOC:
case kindALL:
case kindAPS:
case kindBASETY:
Result = false;
break;
}
return Result;
} /* partunknown */
Void release_(curenv, uniq)
envrec **curenv;
boolean uniq;
{
/* remove leading part of curenv upto and including first marker. Check
for unknown names first though, and if 'uniq' replace the name with its
uniquely extended version */
envrec *cur;
symbol WITH;
/* release */
if (forfull)
{ cur = *curenv;
if (takewarning)
{ while (!ismark(cur))
{ if (partunknown(cur->typc0))
error(22L, NULL, NULL, cur->name0, NULL, true);
cur = cur->next;
}
}
while (!ismark(*curenv)) {
if (uniq)
{ WITH = (*curenv)->name0;
if (WITH->body[0] == specch)
{ WITH->body[0] = 'e';
WITH->length = 3;}
addext(WITH, (*curenv)->uniqext);
}
*curenv = (*curenv)->next;
}
} else
{ while (!ismark(*curenv)) *curenv = (*curenv)->next; }
*curenv = (*curenv)->next; /* marker removed too */
}
Void update(curenv, n, t)
envrec **curenv;
symbol n;
typcrec *t;
{
/* add name n with type t in curenv;
generate unique string (number) as extension;
*/
envrec *r;
r = (envrec *)malloc(sizeof(envrec));
/* added in front, to make removing added elements easy */
r->next = *curenv;
r->name0 = n;
r->typc0 = t;
r->uniqext = extsupply;
if (forfull)
extsupply++;
*curenv = r;
} /* update */
typcrec *lookup(curenv, s)
envrec *curenv;
symbol *s;
{ /* deliver type associated with name s in curenv.
s afterwards points at name in curenv, if found.
s not present <=> lookup=nil */
envrec *env;
env = curenv;
while (true) {
if (env == NULL) return NULL;
if (Equalsymbol(env->name0, *s)) {
*s = env->name0; /* make it point at the same */
return env->typc0;
} else
env = env->next;
}
}
/* operations on lists of names: */
boolean isin(s, slist)
symbol s, slist;
{ /* is s in list slist? */
while (true) {
if (slist == NULL) return false;
else if (Equalsymbol(s, slist)) return true;
else slist = slist->next;
}
}
Void addcopy(s, slist)
symbol s, *slist;
{
/* add s to the list slist */
symbol copy;
copy = Copysymbol(s); /* to keep original ds intact */
copy->next = *slist;
*slist = copy;
} /* addcopy */
Void addunequal(s, slist)
symbol s, *slist;
{
/* s is not allowed already to occur in slist, otherwise added */
if (isin(s, *slist))
error(9L, NULL, NULL, s, NULL, false);
else
addcopy(s, slist);
} /* addunequal */